home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / binarydb / binarymg.bas < prev    next >
BASIC Source File  |  1997-02-19  |  10KB  |  301 lines
  1. Attribute VB_Name = "BinaryMgmt"
  2. 'Database will be a random access text file database
  3. 'List will be a random access text file database with just the headers
  4.  
  5. Public DatabasePath As String
  6. Public BackupDatabasePath As String
  7. Public IndexPath As String
  8. Public dirty As Boolean
  9. Public Any_Change_At_All As Boolean
  10.  
  11. 'this is the delimiter I chose--you can choose another kind if you want
  12. Public Const DOT = "ñ"
  13.  
  14. 'this is the tombstone marker--you can choose another kind if you want
  15. Public Const TOMBSTONE = "@TOMBSTONE@"
  16.  
  17. Private Const DATABASE_RECORD_LIMIT = 65000 'just set it at any limit--it could actually be greater
  18.  
  19. 'you can customize column width without hurting data--i just set it to 20 to make it look nice in listbox
  20. Private Const COLUMN_WIDTH = 20
  21.  
  22. 'you can change these to any unique filenames you want
  23. Private Const DATABASE_NAME = "Inbox.mbx"
  24. Private Const INDEX_NAME = "Inbox.idx"
  25. Private Const BACKUP_DATABASE_NAME = "Inbox.mb0"
  26. Private Const BACKUP_INDEX_NAME = "inbox.id0"
  27.  
  28. 'this indicates where in the IDX (index) file the field for displaying that value is.
  29. Private Const START_BYTE_PART = 1
  30. Private Const LEN_BYTE_PART = 2
  31. Private Const FROM_PART = 3
  32. Private Const SUBJECT_PART = 4
  33. Private Const DATE_PART = 5
  34. Private Const TO_PART = 6
  35. Private Const INDEX_PART = 7
  36.  
  37.  
  38.  
  39. Public Sub AddRecord()
  40. On Error Resume Next
  41.     Any_Change_At_All = True
  42.     frmRec.txtDate = Now
  43.     recnext& = CLng(Val(ReadIndex("RecNext")))
  44.     frmRec.txtIndex = recnext& & ""
  45.     frmRec.Show 1
  46.     BinaryMgmt.AddRecordFinish
  47.     Unload frmRec
  48.     
  49. On Error GoTo 0
  50. On Error Resume Next
  51. End Sub
  52.  
  53. Private Sub AddRecordFinish()
  54. On Error Resume Next
  55.     Dim message As String
  56.     message = Trim(frmRec.txtMessage)
  57.     
  58.     Open DatabasePath For Binary As #1
  59.         byte_next = ReadIndex("ByteNext")
  60.         rec_next = ReadIndex("RecNext")
  61.         Put #1, byte_next, message
  62.     Close #1
  63.     
  64.     len_bytes = Len(message)
  65.     v$ = byte_next & DOT & len_bytes & DOT & Trim(frmRec.txtFrom) & DOT & Trim(frmRec.txtSubject) & DOT & Trim(frmRec.txtDate) & DOT & Trim(frmRec.txtTo) & DOT & "OK"
  66.     WriteIndex "R" & rec_next, v$
  67.     byte_next = byte_next + len_bytes
  68.     WriteIndex "ByteNext", byte_next
  69.     rec_next = rec_next + 1
  70.     WriteIndex "RecNext", rec_next
  71.     ReadAllRecords
  72. On Error GoTo 0
  73. On Error Resume Next
  74. End Sub
  75.  
  76. Public Sub EditRecord()
  77. On Error Resume Next
  78.     If frmMain.List1.ListIndex = 0 Then Exit Sub
  79.     v$ = frmMain.List1.List(frmMain.List1.ListIndex)
  80.     myindex = ParseTab(v$, 5): v$ = ""
  81.     frmRec.txtIndex = myindex
  82.     v$ = ReadIndex("R" & myindex)
  83.     start_byte& = CLng(Val(Parse(v$, START_BYTE_PART)))
  84.     len_bytes& = CLng(Val(Parse(v$, LEN_BYTE_PART)))
  85.     Dim filebuffer As String
  86.     filebuffer = String(len_bytes&, 0)
  87.     Open DatabasePath For Binary As #1
  88.         Get #1, start_byte&, filebuffer
  89.     Close #1
  90.     frmRec.txtDate = Parse(v$, DATE_PART)
  91.     frmRec.txtTo = Parse(v$, TO_PART)
  92.     frmRec.txtFrom = Parse(v$, FROM_PART)
  93.     frmRec.txtSubject = Parse(v$, SUBJECT_PART)
  94.     frmRec.txtMessage = Mid$(filebuffer, 1, len_bytes&)
  95.     frmRec.Show 1
  96.     If dirty = True Then
  97.         BinaryMgmt.EditRecordFinish
  98.         dirty = False
  99.     End If
  100.     Unload frmRec
  101. On Error GoTo 0
  102. On Error Resume Next
  103. End Sub
  104.  
  105. Private Sub EditRecordFinish()
  106. On Error Resume Next
  107.     Any_Change_At_All = True
  108.     Dim message As String
  109.     message = Trim(frmRec.txtMessage)
  110.     
  111.     'tombstone the current record
  112.     myindex = Trim(frmRec.txtIndex)
  113.     readin$ = ReadIndex("R" & CLng(Val(myindex)))
  114.     readin$ = Left(readin$, Len(readin$) - 2) 'strip off ok on end
  115.     readin$ = readin$ & "@TOMBSTONE@"
  116.     WriteIndex "R" & CLng(Val(myindex)), readin$
  117.     
  118.     'write new record to end of database
  119.     Open DatabasePath For Binary As #1
  120.         byte_next = ReadIndex("ByteNext")
  121.         rec_next = ReadIndex("RecNext")
  122.         Put #1, byte_next, message
  123.     Close #1
  124.     
  125.     'write new record to end of index
  126.     len_bytes = Len(message)
  127.     v$ = byte_next & DOT & len_bytes & DOT & Trim(frmRec.txtFrom) & DOT & Trim(frmRec.txtSubject) & DOT & Trim(frmRec.txtDate) & DOT & Trim(frmRec.txtTo) & DOT & "OK"
  128.     WriteIndex "R" & rec_next, v$
  129.     byte_next = byte_next + len_bytes
  130.     WriteIndex "ByteNext", byte_next
  131.     rec_next = rec_next + 1
  132.     WriteIndex "RecNext", rec_next
  133.     
  134.     'redisplay all records
  135.     ReadAllRecords
  136. On Error GoTo 0
  137. On Error Resume Next
  138. End Sub
  139.  
  140. Public Sub DeleteRecord()
  141. On Error Resume Next
  142.     Any_Change_At_All = True
  143.     'tombstone the current record
  144.     If frmMain.List1.ListIndex = 0 Then Exit Sub
  145.     v$ = frmMain.List1.List(frmMain.List1.ListIndex)
  146.     myindex = ParseTab(v$, 5): v$ = ""
  147.     readin$ = ReadIndex("R" & CLng(Val(myindex)))
  148.     readin$ = Left(readin$, Len(readin$) - 2) 'strip off ok on end
  149.     readin$ = readin$ & "@TOMBSTONE@"
  150.     WriteIndex "R" & CLng(Val(myindex)), readin$
  151.  
  152.     'redisplay records
  153.     ReadAllRecords
  154. On Error GoTo 0
  155. On Error Resume Next
  156. End Sub
  157.  
  158.  
  159.  
  160. Public Sub ReadAllRecords()
  161.     On Error Resume Next
  162.     frmMain.List1.Clear
  163.     BuildHeaderList
  164.     v$ = "dummytext"
  165.     Do
  166.         k& = k& + 1
  167.         v$ = ReadIndex("R" & k&)
  168.         If v$ = "" Then Exit Do
  169.         'read all records that aren't tombstones
  170.         If Right$(v$, Len(TOMBSTONE)) <> TOMBSTONE Then
  171.             frmMain.List1.AddItem _
  172.             Pad(Parse(v$, FROM_PART)) & vbTab & _
  173.             Pad(Parse(v$, SUBJECT_PART)) & vbTab & _
  174.             Pad(Parse(v$, DATE_PART)) & vbTab & _
  175.             Pad(Parse(v$, TO_PART)) & vbTab & _
  176.             k&
  177.         End If
  178.     Loop Until v$ = ""
  179.     On Error GoTo 0
  180.     On Error Resume Next
  181. End Sub
  182.  
  183. Public Sub OpenDatabase()
  184.     On Error Resume Next
  185.     DatabasePath = App.Path
  186.     If Right$(DatabasePath, 1) <> "\" Then DatabasePath = DatabasePath + "\"
  187.     DatabasePath = DatabasePath + DATABASE_NAME
  188.     IndexPath = App.Path
  189.     If Right$(IndexPath, 1) <> "\" Then IndexPath = IndexPath + "\"
  190.     IndexPath = IndexPath + INDEX_NAME
  191.     
  192.     If Not FileExists(DatabasePath) Then 'create file
  193.         Open DatabasePath For Output As #1
  194.         Close #1
  195.         Open IndexPath For Output As #1
  196.             Print #1, "[Index]"
  197.             Print #1, "RecNext = 1"
  198.             Print #1, "ByteNext = 1"
  199.         Close #1
  200.     End If
  201.     On Error GoTo 0
  202.     On Error Resume Next
  203.     
  204. End Sub
  205.  
  206. Private Function FileExists(ByVal f$) As Boolean
  207.     On Error Resume Next
  208.     SetAttr f$, vbNormal
  209.     If Err Then
  210.         FileExists = False
  211.     Else
  212.         FileExists = True
  213.     End If
  214.     On Error GoTo 0
  215.     On Error Resume Next
  216. End Function
  217.  
  218.  
  219. Private Function Pad(ByVal incoming As String) As String
  220.     On Error Resume Next
  221.     Select Case Len(incoming)
  222.         Case Is < COLUMN_WIDTH
  223.             incoming = incoming & Space(COLUMN_WIDTH - Len(incoming))
  224.         Case Is > COLUMN_WIDTH
  225.             incoming = Left$(incoming, COLUMN_WIDTH)
  226.     End Select
  227.     Pad = incoming
  228.     On Error GoTo 0
  229.     On Error Resume Next
  230. End Function
  231.  
  232. Private Sub BuildHeaderList()
  233.     On Error Resume Next
  234.     Dim colheaders(5) As String
  235.     colheaders(1) = "From"
  236.     colheaders(2) = "Subject"
  237.     colheaders(3) = "Date"
  238.     colheaders(4) = "To"
  239.     colheaders(5) = "ID"
  240.     For k% = 1 To 5
  241.         header_row = header_row & Pad(colheaders(k%)) & " " & vbTab
  242.     Next k%
  243.     frmMain.List1.AddItem header_row
  244.     On Error GoTo 0
  245.     On Error Resume Next
  246. End Sub
  247.  
  248. Public Sub CompactDatabase()
  249. 'Exit Sub
  250. 'BREAK
  251.     On Error Resume Next
  252.     
  253.     readin = 1
  254.     readout = 2
  255.     
  256.     'kill last database backup and backup the current database file, then kill database file
  257.     BackupDatabasePath = App.Path
  258.     If Right$(BackupDatabasePath, 1) <> "\" Then BackupDatabasePath = BackupDatabasePath & "\"
  259.     BackupDatabasePath = BackupDatabasePath + BACKUP_DATABASE_NAME
  260.     Kill BackupDatabasePath
  261.     FileCopy DatabasePath, BackupDatabasePath 'BackupDatabasePath is now the old database
  262.     Kill DatabasePath 'so it can now hold the new database
  263.     
  264.     'open backup (data